;;;; Experiments in Key-Value-Coding

(in-package :cl-user)

(defun nsstr (s) (ccl::%make-nsstring s))
(defun lisp-string (ns) (%get-cstring (#/UTF8String ns)))

(defclass kvc-implementor (ns:ns-object)
  ((prop :accessor prop :initform 1)
   (num :foreign-type :int
	:accessor ivar-num)
   (dashed-property :foreign-type :id
		    :accessor dashed-property))
  (:metaclass ns:+ns-object))

(defclass sub-kvc-implementor (ns:ns-object)
  ((value :accessor value :initform 'value)
   (fvalue :foreign-type :id
	   :accessor fvalue))
  (:metaclass ns:+ns-object))

(defun lisp->kvc-compliant (value)
  (typecase value
    (double-float (#/numberWithDouble: ns:ns-number value))
    (float (#/numberWithFloat: ns:ns-number value))
    (bignum (#/numberWithLongLong: ns:ns-number value))
    (fixnum (#/numberWithInt: ns:ns-number value))
    (string (nsstr value))
    (character (nsstr (string value)))
    (symbol (nsstr (symbol-name value)))
    (list (let ((ret-array (make-instance 'ns:ns-mutable-array)))
	    (dolist (item value ret-array)
	      (format t "~A~%" (type-of item))
	      (#/addObject: ret-array (lisp->kvc-compliant item)))))
    (t (error "Value ~A does not have a translation for key-value coding." value))))

(objc:defmethod (#/prop :id) ((obj kvc-implementor))
  (lisp->kvc-compliant (prop obj)))

(objc:defmethod (#/setProp: :void) ((obj kvc-implementor) num)
  (format t "Setting prop to ~A~%" (#/intValue num))
  (setf (prop obj) (#/intValue num)))

(objc:defmethod (#/isProp #>BOOL) ((obj kvc-implementor))
  (declare (ignore obj))
  #$YES)

(objc:defmethod (#/isValue #>BOOL) ((obj sub-kvc-implementor))
  (declare (ignore obj))
  #$YES)

(objc:defmethod (#/value :id) ((obj sub-kvc-implementor))
  (lisp->kvc-compliant (value obj)))

(defun test-kvc-types ()
  (format t "~A~%" (lisp->kvc-compliant 2))
  (format t "~A~%" (lisp->kvc-compliant 1))
  (format t "~A~%" (lisp->kvc-compliant 102938))
  (format t "~A~%" (lisp->kvc-compliant 2.0))
  (format t "~A~%" (lisp->kvc-compliant 2.0d0))
  (format t "~A~%" (lisp->kvc-compliant "I am KVC compliant!"))
  (format t "~A~%" (lisp->kvc-compliant #\A))
  (format t "~A~%" (lisp->kvc-compliant 'lisp-symbol))
  (format t "~A~%" (lisp->kvc-compliant '(a b c d e)))
  (format t "~A~%" (lisp->kvc-compliant (list 'a 'b 'c (list 'd 'e)))))

(defun test-kvc-properties ()
  (let ((kvc (make-instance 'kvc-implementor))
	(sub-kvc (make-instance 'sub-kvc-implementor)))
    (format t "Prop = ~A~%" (#/valueForKey: kvc #@"prop"))
    (format t "Ivar = ~A~%" (#/valueForKey: kvc #@"num"))
    (#/setValue:forKey: kvc (#/numberWithInt: ns:ns-number 25) #@"prop")
    (#/setValue:forKey: kvc (#/numberWithInt: ns:ns-number 3) #@"num")
    (format t "After setValue:forKey:, Prop = ~A, Ivar = ~A~%" 
	    (#/valueForKey: kvc #@"prop")
	    (#/valueForKey: kvc #@"num"))
    (setf (dashed-property kvc) sub-kvc)
    (format t "dashedProperty = ~A~%" (#/valueForKey: kvc #@"dashedProperty"))
    (format t "Value = ~A~%" (#/valueForKey: (#/valueForKey: kvc #@"dashedProperty") #@"value"))
    (format t "Dotted property = ~A~%" (#/valueForKeyPath: kvc #@"dashedProperty.value"))))


;;;;
;;;

(defclass cp-inspector (ns:ns-object)
  ((object :accessor cp-object :initarg :object))
  (:metaclass ns:+ns-object))

;; This seems to work, but I wonder what unintended
;; consequences I court by not making copies of the
;; lisp object pointed to by the inspector object...
(objc:defmethod (#/copyWithZone: :id) ((self cp-inspector) zone)
  (declare (ignore zone))
  (make-instance 'cp-inspector :object (cp-object self)))

(defun lisp->kvc-compliant (value)
  (typecase value
    (double-float (#/numberWithDouble: ns:ns-number value))
    (float (#/numberWithFloat: ns:ns-number value))
    (bignum (#/numberWithLongLong: ns:ns-number value))
    (fixnum (#/numberWithInt: ns:ns-number value))
    (string (nsstr value))
    (character (nsstr (string value)))
    (symbol (nsstr (symbol-name value)))
    (list (let ((ret-array (make-instance 'ns:ns-mutable-array)))
	    (dolist (item value ret-array)
	      (format t "~A~%" (type-of item))
	      (#/addObject: ret-array (lisp->kvc-compliant item)))))
    (t (make-instance 'cp-inspector :object value))))

;;; Here we specify the type since NSString's are overloaded
;;; to represent symbols, characters, and strings.
;;; It makes working with NSNumber's every so slightly easier, too.
(defun kvc-compliant->lisp (value type)
  (case type
    (:double (#/doubleValue value))
    (:float (#/floatValue value))
    (:int (#/intValue value))
    (t value)))

(defmacro atomic-kvc-accessor (name accessor-fn type)
  (let ((set-key (intern (concatenate 'string "set"
				      (string-upcase (char (symbol-name name) 0))
				      (string-downcase (subseq (symbol-name name) 1))
				      ":")
			 "NEXTSTEP-FUNCTIONS")))
    (aux:with-unique-names (robj sobj nval)
      `(progn
	 (objc:defmethod (,(intern (symbol-name name) "NEXTSTEP-FUNCTIONS") :id) ((,robj cp-inspector))
	   (lisp->kvc-compliant (,accessor-fn (cp-object ,robj))))
	 (objc:defmethod (,set-key :void) ((,sobj cp-inspector) ,nval)
	   (setf (,accessor-fn (cp-object ,sobj)) (kvc-compliant->lisp ,nval ,type)))))))

(defmacro composite-kvc-accessor (name accessor-fn)
  (aux:with-unique-names (obj prop)
    `(objc:defmethod (,(intern (symbol-name name) "NEXTSTEP-FUNCTIONS") :id) ((,obj cp-inspector))
       (let ((,prop (,accessor-fn (cp-object ,obj))))
	 (typecase ,prop
	   (list (lisp->kvc-compliant ,prop))
	   (t (make-instance 'cp-inspector :object (,accessor-fn (cp-object ,obj)))))))))

(defmacro kvc-key (name)
  (let ((key-name-fn (intern (concatenate 'string "is" 
					  (string-upcase (char (symbol-name name) 0))
					  (string-downcase (subseq (symbol-name name) 1)))
			     "NEXTSTEP-FUNCTIONS")))
    `(objc:defmethod (,key-name-fn #>BOOL) ((ignore cp-inspector))
       (declare (ignore ignore))
       #$YES)))

;; -- cpObjects --
(atomic-kvc-accessor |name| cp:name :symbol)

;; -- Spaces --
(composite-kvc-accessor |gravity| cp:gravity)
(atomic-kvc-accessor |bodies| cp:bodies :list)
(atomic-kvc-accessor |shapes| cp:shapes :list)
(atomic-kvc-accessor |joints| cp:joints :list)

;; -- Vectors --
(atomic-kvc-accessor |x| cp:cpv.x :double)
(atomic-kvc-accessor |y| cp:cpv.y :double)

;; -- Bodies --
(atomic-kvc-accessor |mass| cp:mass :double)
(atomic-kvc-accessor |moment| cp:moment :double)
(composite-kvc-accessor |pos| cp:pos)

;; -- Shapes --
(composite-kvc-accessor |body| cp:body)
(atomic-kvc-accessor |elasticity| cp:elasticity :double)
(atomic-kvc-accessor |friction| cp:friction :double)
(atomic-kvc-accessor |friction| cp:collision-type :int)

;; -- Circle --
(atomic-kvc-accessor |radius| cp:radius :double)
(composite-kvc-accessor |center| cp:center)

;; -- Segment --
(atomic-kvc-accessor |thickness| cp:thickness :double)
(composite-kvc-accessor |startPoint| cp:start-point)
(composite-kvc-accessor |endPoint| cp:end-point)

;; Using a TreeController to inspect modify a CLOS instance's slots

(defparameter *slots-to-ignore* '(cp::ptr))

(objc:defmethod (#/slotDefs :id) ((self cp-inspector))
  (let ((slots (compute-slots (class-of (cp-object self))))
	(sarray (#/array ns:ns-mutable-array)))
    (dolist (s slots sarray)
      (let ((name (slot-value s 'ccl::name)))
	(unless (find name *slots-to-ignore*)
	  (#/addObject: sarray (#/dictionaryWithObjectsAndKeys:
				ns:ns-dictionary
				(#/autorelease (ccl::%make-nsstring (symbol-name name)))
				#@"name"
				(lisp->kvc-compliant (slot-value (cp-object self) name))
				#@"value"
				+null-ptr+)))))))
  
    
(defun test-cp-bindings ()
  (let* ((vec (make-instance 'cp-inspector
                :object (cp:cpv 2 4)))
         (circle (make-instance 'cp-inspector
                   :object (make-instance 'cp:circle-shape
                             :body (make-instance 'cp:body
                                     :mass 1.0 :moment 1.0
                                     :position (cp:cpv 101 10))
                             :radius 5.0
                             :offset cp:+cpvzero+)))
         (bod (make-instance 'cp-inspector
                :object (make-instance 'cp:body
                          :mass 1.0
                          :moment 1.0
                          :position (cp:cpv 1 1))))
         (space (make-instance 'cp-inspector
                  :object (cp::create-test-space))))
    (format t "Vector (~A, ~A)~%" (#/x vec) (#/valueForKey: vec #@"y"))
    (format t "Position of ~A = (~A, ~A)~%" bod (#/doubleValue (#/valueForKeyPath: bod #@"pos.x"))
	    (#/valueForKeyPath: bod #@"pos.y"))
    (format t "Position check = (~A, ~A)~%" (cp:cpv.x (cp:pos (cp-object bod))) (cp:cpv.y (cp:pos (cp-object bod))))
    (#/setValue:forKeyPath: bod (#/numberWithDouble: ns:ns-number 25.0d0) #@"pos.x")
    (format t "Circle ~A at (~A, ~A) with radius ~A and center ~A.~%"
            (#/valueForKey: circle #@"name")
            (#/valueForKeyPath: circle #@"body.pos.x")
            (#/valueForKeyPath: circle #@"body.pos.y")
            (#/valueForKey: circle #@"radius")
	    (cp-object (#/valueForKey: circle #@"center")))
            ;(#/valueForKey: circle #@"center.x")
            ;(#/valueForKey: circle #@"center.y"))
    (format t "Shapes: ~A~%Bodies: ~A~%" 
	    (#/valueForKey: space #@"shapes") (#/valueForKey: space #@"bodies"))))

(defun test-cp-tree-access ()
  (let* ((vec (make-instance 'cp-inspector
			     :object (cp:cpv 2 4)))
         (circle (make-instance 'cp-inspector
				:object (make-instance 'cp:circle-shape
					  :body (make-instance 'cp:body
						  :mass 1.0 :moment 1.0
                                     :position (cp:cpv 101 10))
                             :radius 5.0
                             :offset cp:+cpvzero+)))
         (bod (make-instance 'cp-inspector
			     :object (make-instance 'cp:body
				       :mass 1.0
                          :moment 1.0
                          :position (cp:cpv 1 1))))
         (space (make-instance 'cp-inspector
			       :object (cp::create-test-space))))
    (format t "Vec slots: ~A~%" (#/slotDefs vec))
    (format t "Circle slots: ~A~%" (#/slotDefs circle))))

;;; A Simple Object Controller

(defclass body-object-viewer (ns:ns-window-controller)
  ((inspector :foreign-type :id :accessor inspector))
  (:metaclass ns:+ns-object))

(objc:defmethod #/init ((wc body-object-viewer))
  (prog1
      (#/initWithWindowNibName: wc #@"SampleObjectEditor")
    (setf (inspector wc) (make-instance 'cp-inspector :object (make-instance 'cp:body
									     :mass 1
									     :moment 1
									     :position (cp:cpv 0 0))))))

(objc:defmethod (#/windowDidLoad :void) ((wc body-object-viewer))
  (#/makeKeyAndOrderFront: (#/window wc) wc))

(objc:defmethod (#/windowWillClose :void) ((wc body-object-viewer) notification)
  (declare (ignore notification))
  (#/autorelease wc))

(defun body-viewer ()
  (gui::execute-in-gui #'(lambda ()
                           (let ((wc (make-instance 'body-object-viewer)))
                             (#/showWindow: wc nil)
			     wc))))


;;; Check out apropos-window.lisp in the Cocoa IDE for
;;; a good example of using an Array controller.

;;; A view using a Tree Controller and an Array Controller

(defparameter *default-image* (make-instance 'ns:ns-image
					     :init-by-referencing-file 
					     #@"/Users/millejoh/Applications/dreaming-tree/data/balance_chipmunk.png"))

(defclass simple-space-editor (ns:ns-window-controller)
  ((space :accessor space :initarg :space)
   (shape-browser :foreign-type :id :accessor shape-browser)
   (shape-editor :foreign-type :id :accessor shape-editor)
   (shape-list :foreign-type :id :reader shape-list :initform +null-ptr+)
   (selected-object :foreign-type :id :accessor selected-object :initform +null-ptr+))
  (:metaclass ns:+ns-object))

(defclass shape-item-view (ns:ns-view)
  ((delegate :foreign-type :id :accessor delegate))
  (:metaclass ns:+ns-object))

(objc:defmethod (#/copyWithZone: :id) ((self shape-item-view) zone)
  (let ((copy (#/initWithFrame: (#/allocWithZone: shape-item-view zone)
				(#/frame self))))
    (setf (delegate copy) (delegate self))
    copy))

(objc:defmethod (#/acceptsFirstResponder #>BOOL) ((self shape-item-view))
  #$YES)

(objc:defmethod (#/hitTest: :id) ((self shape-item-view) point)
  (if (#_NSPointInRect point (#/convertRect:toView: self (#/bounds self) (#/superview self)))
      (progn
	self)
      +null-ptr+))

(objc:defmethod (#/mouseDown: :void) ((self shape-item-view) event)
  (call-next-method event)
  (when (>= (#/clickCount event) 2)
    (with-slots (shape-list space shape-browser selected-object) (#/delegate (#/window self))
      (let ((sel (#/objectAtIndex: shape-list
				   (#/firstIndex (#/selectionIndexes shape-browser)))))
	(format t "~A~%" (cp:find-in-space space (lisp-string (#/objectForKey: sel #@"name"))))
	(setf selected-object (make-instance 'cp-inspector 
					     :object (cp:find-in-space space (lisp-string (#/objectForKey: sel #@"name")))))
	(#/makeKeyAndOrderFront: (shape-editor (#/delegate (#/window self))) self)))))

(objc:defmethod #/init ((wc simple-space-editor))
  (prog1
      (#/initWithWindowNibName: wc #@"SampleArrayEditor")
    (setf (slot-value wc 'shape-list) (#/array ns:ns-mutable-array))))

(defmethod update-shape-list ((self simple-space-editor))
  (let ((shape-list (#/array ns:ns-mutable-array)))
    (dolist (s (cp:shapes (space self)))
      (#/addObject: shape-list (#/dictionaryWithObjectsAndKeys:
				ns:ns-dictionary
				(#/autorelease (ccl::%make-nsstring (cp:name s)))
				#@"name"
				*default-image*
				#@"image"
				+null-ptr+)))
    (#/willChangeValueForKey: self #@"shapeList")
    (setf (slot-value self 'shape-list) shape-list)
    (#/didChangeValueForKey: self #@"shapeList")))

(defmethod initialize-instance :after ((self simple-space-editor) &rest initargs)
  (declare (ignore initargs))
  (update-shape-list self))

(objc:defmethod (#/windowDidLoad :void) ((wc simple-space-editor))
  (#/makeKeyAndOrderFront: (#/window wc) wc))

			 
(defun space-viewer (&optional (space (cp::create-test-space)))
  (gui::execute-in-gui #'(lambda ()
                           (let ((wc (make-instance 'simple-space-editor :space space)))
                             (#/showWindow: wc nil)
			     wc))))


;;; This smells of hack, but it's in Apple's example code so it must be okay!

(defclass icon-view-box (ns:ns-box)
  ()
  (:metaclass ns:+ns-object))

(objc:defmethod (#/hitTest: :id) ((self icon-view-box) point)
  (declare (ignore point))
  +null-ptr+)